home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 April / CICA MS Windows - April 1993.iso / unzipped / programr / tp / dprin101 / dprint.pas next >
Pascal/Delphi Source File  |  1992-05-17  |  7KB  |  255 lines

  1.  
  2. {*************************************************************
  3.  
  4.    Unit DPrint « for Turbo Pascal for Windows
  5.  
  6.    Copyright ⌐ 1992 by :
  7.  
  8.         PHADE SOFTWARE
  9.         Inh. Frank Gadegast
  10.         Leibnizstr. 30
  11.         1000 Berlin 12 GERMANY
  12.  
  13.         Tel. : (030) 312 81 03
  14.  
  15.     Version 1.01 / 17.5.92
  16.  
  17. **************************************************************}
  18.  
  19. unit dprint;
  20.  
  21. {--------------------------------------------------------------------------------}
  22. {--------------------------------------------------------------------------------}
  23.  
  24. interface
  25.  
  26. uses    WObjects, WinTypes, WinProcs, Strings;
  27.  
  28. const
  29.     prn_print    = 101;
  30.     prn_cancel    = 102;
  31.     prn_setup    = 103;
  32.     prn_control    = 104;
  33.     prn_list    = 105;
  34.  
  35.     prn_text    = 101;
  36.  
  37. type
  38.     PSetupDialog = ^TSetupDialog;
  39.     TSetupDialog = object (TDialog)
  40.         theList    :    PChar;
  41.  
  42.         constructor Init (AParent : PWindowsObject; AName : PChar; thePrinters : PChar);
  43.         procedure SetupWindow; virtual;
  44.         procedure Print (var Msg : TMessage); virtual id_First + prn_print;
  45.         procedure CancelDlg (var Msg : TMessage); virtual id_First + prn_cancel;
  46.         procedure Setup (var Msg : TMessage); virtual id_First + prn_setup;
  47.         procedure Control (var Msg : TMessage); virtual id_First + prn_control;
  48.     end;
  49.  
  50. function PrinterSetup (ParWnd : HWnd) : boolean;
  51.  
  52. {--------------------------------------------------------------------------------}
  53. {--------------------------------------------------------------------------------}
  54.  
  55. implementation
  56.  
  57. {$R dprint.res}
  58.  
  59. var
  60.     setupup        : boolean;
  61.     setupcancel    : boolean;
  62.  
  63. {--------------------------------------------------------------------------------}
  64. {--------------------------------------------------------------------------------}
  65.  
  66. function strtoc (str : PChar; tok : char; count : integer) : PChar;
  67.  
  68. var i, word            : integer;
  69.     tempsrc            : PChar;
  70.     tempb, tempe    : PChar;
  71.  
  72. begin
  73.     tempsrc := StrNew (str);
  74.     tempe := strscan (tempsrc, tok);
  75.     tempb := tempsrc;
  76.     word := 1;
  77.     for i := 0 to strlen (str) do
  78.     begin
  79.         if word = count then
  80.         begin
  81.             if tempe <> nil then
  82.             begin
  83.                 tempe^ := #0;
  84.                    strtoc := tempb;
  85.             end
  86.             else tempe := strend (tempb);
  87.             strtoc := tempb;
  88.         end
  89.         else
  90.         if tempsrc [i] = tok then
  91.         begin
  92.             inc (word);
  93.             inc (i);
  94.             tempb := PChar (addr (tempsrc [i]));
  95.             tempe := strscan (tempb, tok);
  96.         end;
  97.     end;
  98. end;
  99.  
  100. {--------------------------------------------------------------------------------}
  101. {--------------------------------------------------------------------------------}
  102.  
  103. constructor TSetupDialog.Init (AParent : PWindowsObject; AName : PChar;
  104.                                 thePrinters : PChar);
  105. begin
  106.     TDialog.Init (AParent, AName);
  107.     theList := thePrinters;
  108. end;
  109.  
  110. {--------------------------------------------------------------------------------}
  111.  
  112. procedure TSetupDialog.SetupWindow;
  113.  
  114. var cur            : PChar;
  115.     index        : integer;
  116.     szPrinter    : array [0..64] of char;
  117.     pDevice        : PChar;
  118.  
  119. begin
  120.     TDialog.SetupWindow;
  121.     cur := theList;
  122.     while cur^ <> #0 do
  123.     begin
  124.         SendDlgItemMsg (prn_list, LB_ADDSTRING, 0, LongInt (cur));
  125.         cur := cur + strlen (cur) + 1;
  126.     end;
  127.     if GetProfileString
  128.         ('windows', 'device', '', szPrinter, sizeof (szprinter)) <> 0 then
  129.     begin
  130.         pDevice := strtoc (szPrinter, ',', 1);
  131.         index := SendDlgItemMsg (prn_list, LB_FINDSTRING, 0, LongInt (pDevice));
  132.         if index > -1 then SendDlgItemMsg (prn_list, LB_SETCURSEL, index, 0);
  133.     end
  134.     else SendDlgItemMsg (prn_list, LB_SETCURSEL, index, 0);
  135.  
  136. end;
  137.  
  138. {--------------------------------------------------------------------------------}
  139.  
  140. procedure TSetupDialog.Print (var Msg : TMessage);
  141.  
  142. var index        : integer;
  143.     szPrinter    : array [0..64] of char;
  144.     szDevice    : PChar;
  145.  
  146. begin
  147.     szDevice := Strnew ('                                                  ');
  148.     index := SendDlgItemMsg (prn_list, LB_GETCURSEL, 0, 0);
  149.     if index <> lb_err then
  150.     begin
  151.         SendDlgItemMsg (prn_list, LB_GETTEXT, index, LongInt (szDevice));
  152.         GetProfileString ('devices', szDevice, '', szPrinter, sizeof (szPrinter));
  153.         strcat (szdevice, ',');
  154.         strcat (szdevice, szPrinter);
  155.         WriteProfileString ('windows', 'device', szDevice);
  156.         EndDlg (0);
  157.     end
  158.     else
  159.     begin
  160.         MessageBox (HWindow, 'No printer selected !',
  161.             'Print Error', mb_Ok or mb_IconStop);
  162.     end;
  163. end;
  164.  
  165. {--------------------------------------------------------------------------------}
  166.  
  167. procedure TSetupDialog.CancelDlg (var Msg : TMessage);
  168. begin
  169.     TDialog.EndDlg (0);
  170.     setupcancel := true;
  171. end;
  172.  
  173. {--------------------------------------------------------------------------------}
  174.  
  175. procedure TSetupDialog.Setup (var Msg : TMessage);
  176.  
  177. type TDevFunc = function (hw : HWnd; th : THandle; pd : LongInt; po : LongInt) : integer;
  178.  
  179. var index        : integer;
  180.     curDev        : PChar;
  181.     szDevice    : array [0..64] of char;
  182.     szDriver    : array [0..64] of char;
  183.     pDevice,
  184.     pDriver,
  185.     pOutput        : PChar;
  186.     hDriver     : THandle;
  187.     DevFunc        : TDevFunc;
  188.     fpDevMode    : TFarProc ;
  189.  
  190. begin
  191.        curDev := Strnew ('                                                  ');
  192.     index := SendDlgItemMsg (prn_list, LB_GETCURSEL, 0, 0);
  193.     if index <> lb_err then
  194.     begin
  195.         SendDlgItemMsg (prn_list, LB_GETTEXT, index, LongInt (curdev));
  196.         GetProfileString ('devices', curdev, '', szdevice, sizeof (szdevice));
  197.         pDriver := strtoc (szdevice, ',', 1);
  198.         pOutput := strtoc (szdevice, ',', 2);
  199.         pDevice := curdev;
  200.         strcopy (szDriver, pDriver);
  201.         strcat (szDriver, '.DRV');
  202.  
  203.         hDriver := LoadLibrary (szDriver);
  204.         if hDriver < 32 then exit;
  205.  
  206.         fpDevMode := GetProcAddress (hDriver, 'DeviceMode');
  207.         if fpDevMode = nil then
  208.            begin
  209.             FreeLibrary (hDriver);
  210.             exit;
  211.            end;
  212.  
  213.         DevFunc := TDevFunc (fpDevMode);
  214.         DevFunc (getfocus, hDriver, LongInt (pDevice), LongInt (pOutput));
  215.  
  216.         FreeLibrary (hDriver);
  217.     end;
  218. end;
  219.  
  220. {--------------------------------------------------------------------------------}
  221.  
  222. procedure TSetupDialog.Control (var Msg : TMessage);
  223.  
  224. begin
  225.     WinExec ('CONTROL.EXE', sw_ShowNormal);
  226. end;
  227.  
  228. {--------------------------------------------------------------------------------}
  229.  
  230. function PrinterSetup (ParWnd : HWnd) : boolean;
  231.  
  232. var szDevices    : array [0..2048] of char;
  233.     dlgret        : integer;
  234.  
  235. begin
  236.     if setupup = true then PrinterSetup := false
  237.     else
  238.     begin
  239.         setupup := true;
  240.         setupcancel := false;
  241.         GetProfileString ('devices', nil, '', szdevices, sizeof (szdevices));
  242.         Application^.Execdialog (new (PSetupDialog,
  243.             Init (Application^.MainWindow, 'PRINTERSETUP', szdevices)));
  244.         PrinterSetup := not setupcancel;
  245.         EnableWindow (ParWnd, true);
  246.         setupup := false;
  247.     end;
  248. end;
  249.  
  250. {--------------------------------------------------------------------------------}
  251. {--------------------------------------------------------------------------------}
  252.  
  253. begin
  254.     setupup := false;
  255. end.